/// /////////////////////////////////////////////
// 单元名 : unitClientUpdateObj
// 作者 : Hawk
// 单元描述 : 客户端自更新对象
// 日期 : 2023-09-15
/// /////////////////////////////////////////////

{$IFDEF FPC}
{$H+}
{$MODE DELPHI}
{$ENDIF}
unit unitClientUpdateObj;

interface

uses
{$IFDEF MSWINDOWS}
  Windows,
{$ENDIF}
  unitCommonTypes, unitCommonDataStruct, unitIOCPDataObj, unitMisc{$IFDEF UI}, unitClientBuffer{$ENDIF};

type
  TUpdateMode = (umDefault, umOnlyNew);

  TUpdateFileObj = class(TSerialObj)
  private
    FDeployPath: CommonString;
    FDeployFileName: CommonString;
    FFileID: TID_OBJ;
    FFileHash: THASH_VAL;
    FModTime: FILETIME;
    FVerOnSvr: TVER_INFO;
    FFileSize: int64;
    FUpdateMode: TUpdateMode;
    procedure SetFilePath(const Value: CommonString);
    procedure SetFileID(const Value: TID_OBJ);
    procedure SetDeployFileName(const Value: CommonString);
    procedure SetFileHash(const Value: THASH_VAL);
    procedure SetFileSize(const Value: int64);
    procedure SetModTime(const Value: FILETIME);
    procedure SetVerOnSvr(const Value: TVER_INFO);
    procedure SetUpdateMode(const Value: TUpdateMode);
  protected
    procedure DoClone(Target: TSerialObj); override;
    procedure DoAssign(Source: TSerialObj); override;
    procedure DoReadFromPack(PropertyIdx, Len: Longword; Buf: TIOCPDataCollecter); override;
    procedure DoWritePropertyToPack(dp: TIOCPDataCollecter); override;

    function DoCheckLocalVer(DepFullName: CommonString): Boolean;
  public
    class function ClassID: Longword; override;
    procedure Return; override;

    property DeployPath: CommonString read FDeployPath write SetFilePath;
    property DeployFileName: CommonString read FDeployFileName write SetDeployFileName;
    property FileID: TID_OBJ read FFileID write SetFileID;
    property VerOnSvr: TVER_INFO read FVerOnSvr write SetVerOnSvr;
    property FileHash: THASH_VAL read FFileHash write SetFileHash;
    property FileSize: int64 read FFileSize write SetFileSize;
    property ModTime: FILETIME read FModTime write SetModTime;
    property UpdateMode: TUpdateMode read FUpdateMode write SetUpdateMode;
  end;

  TUpdateableFileInfo = class(TSerialObj)
  private
    FFileVer: TVER_INFO;
    FFileSize: int64;
    FFileHash: THASH_VAL;
    FModTime: FILETIME;
    FUpdateMode: TUpdateMode;
    procedure SetFileName(const Value: CommonString);
    procedure SetFileHash(const Value: THASH_VAL);
    procedure SetFileSize(const Value: int64);
    procedure SetFileVer(const Value: TVER_INFO);
    procedure SetModTime(const Value: FILETIME);
    function GetFileName: CommonString;
    procedure SetUpdateMode(const Value: TUpdateMode);
  protected
    procedure DoClone(Target: TSerialObj); override;
    procedure DoAssign(Source: TSerialObj); override;
    procedure DoReadFromPack(PropertyIdx, Len: Longword; Buf: TIOCPDataCollecter); override;
    procedure DoWritePropertyToPack(dp: TIOCPDataCollecter); override;
  public
    class function ClassID: Longword; override;
    procedure Return; override;

    property FileName: CommonString read GetFileName write SetFileName;
    property FileSize: int64 read FFileSize write SetFileSize;
    property FileVer: TVER_INFO read FFileVer write SetFileVer;
    property FileHash: THASH_VAL read FFileHash write SetFileHash;
    property ModTime: FILETIME read FModTime write SetModTime;
    property UpdateMode: TUpdateMode read FUpdateMode write SetUpdateMode;
  end;

{$IFDEF UI}

  TUpdateableProject = class(TClientObjList)
{$ELSE}
  TUpdateableProject = class(TStoreList)
{$ENDIF}
  private
    FDeployPath: CommonString;
    procedure SetDeployPath(const Value: CommonString);
    function ExpandPath(S: CommonString): CommonString;
    function GetDeployName(obj: TUpdateFileObj): CommonString;
  protected
    procedure DoClone(Target: TSerialObj); override;
    procedure DoAssign(Source: TSerialObj); override;
    procedure DoReadFromPack(PropertyIdx, Len: Longword; Buf: TIOCPDataCollecter); override;
    procedure DoWritePropertyToPack(dp: TIOCPDataCollecter); override;
  public
    class function ClassID: Longword; override;
    procedure Return; override;

    function AddFileObj(obj: TUpdateFileObj; assoFileInfo: TUpdateableFileInfo): ERRCODE;
    function FindFileObjByFileID(const FileID: TID_OBJ): TUpdateFileObj;
    procedure CheckUpdateableObjs;
    procedure UpdateFileObj(const FileID: TID_OBJ; FN: CommonString);

    property DeployPath: CommonString read FDeployPath write SetDeployPath;
  end;

const
  S_ENVIRONMENT_INSTALLPATH: CommonString = '%installpath%';
  S_ENVIRONMENT_CURRENTPATH: CommonString = '%currentpath%';
  S_ENVIRONMENT_PROGRAMPATH: CommonString = '%programpath%';
  S_FILEEXT_OLD = '.old';
  S_UPDATEMODE: array [TUpdateMode] of CommonString = ('按照版本号', '按文件日期');

  // I_UPABLEPRJDETAIL: TID_OBJ = (ObjType: 5; IDBuf: ($39, $31, $69, $F3, $03, $B5, $45, $05, $98, $41, $94, $2C, $5D,
  // $6F, $68));
  // S_UPABLEPRJDETAIL = '可更新项目细目表';
  //
implementation

uses SysUtils, unitObjPool, unitClassIDDef, unitErrCodeDef;

{ TUpdateableFileInfo }

class function TUpdateableFileInfo.ClassID: Longword;
begin
  Result := CLASSID_CLIENTFILEINFO;
end;

procedure TUpdateableFileInfo.DoAssign(Source: TSerialObj);
var
  src: TUpdateableFileInfo ABSOLUTE Source;
begin
  inherited;
  FFileVer := src.FFileVer;
  FFileHash := src.FFileHash;
  FFileSize := src.FFileSize;
  FModTime := src.FModTime;
  FUpdateMode := src.FUpdateMode;
end;

procedure TUpdateableFileInfo.DoClone(Target: TSerialObj);
var
  tgt: TUpdateableFileInfo ABSOLUTE Target;
begin
  inherited;
  tgt.FFileVer := FFileVer;
  tgt.FFileHash := FFileHash;
  tgt.FFileSize := FFileSize;
  tgt.FModTime := FModTime;
  tgt.FUpdateMode := FUpdateMode;
end;

procedure TUpdateableFileInfo.DoReadFromPack(PropertyIdx, Len: Longword; Buf: TIOCPDataCollecter);
begin
  case PropertyIdx of
    2:
      Buf.ReadBuf(FFileVer, Len);
    3:
      Buf.ReadBuf(FUpdateMode, Len);
  else
    inherited;
  end;
end;

procedure TUpdateableFileInfo.DoWritePropertyToPack(dp: TIOCPDataCollecter);
begin
  inherited;
  WritePropertyToPack(dp, 2, SizeOf(FFileVer) + SizeOf(FFileSize) + SizeOf(FFileHash) + SizeOf(FModTime), FFileVer);
  WritePropertyToPack(dp, 3, SizeOf(FUpdateMode), FUpdateMode);
end;

function TUpdateableFileInfo.GetFileName: CommonString;
begin
  Result := Caption;
end;

procedure TUpdateableFileInfo.Return;
begin
  inherited;
  FFileHash.Empty;
  FFileVer.Ver := 0;
  FFileSize := 0;
  FUpdateMode := umDefault;
end;

procedure TUpdateableFileInfo.SetFileHash(const Value: THASH_VAL);
begin
  if FFileHash <> Value then
    FFileHash := Value;
end;

procedure TUpdateableFileInfo.SetFileName(const Value: CommonString);
begin
  Caption := Value;
end;

procedure TUpdateableFileInfo.SetFileSize(const Value: int64);
begin
  if FFileSize <> Value then
  begin
    FFileSize := Value;
    DoModifyed;
  end;
end;

procedure TUpdateableFileInfo.SetFileVer(const Value: TVER_INFO);
begin
  if FFileVer.Ver <> Value.Ver then
  begin
    FFileVer := Value;
    DoModifyed;
  end;
end;

procedure TUpdateableFileInfo.SetModTime(const Value: FILETIME);
begin
  FModTime := Value;
  DoModifyed;
end;

procedure TUpdateableFileInfo.SetUpdateMode(const Value: TUpdateMode);
begin
  if FUpdateMode <> Value then
  begin
    FUpdateMode := Value;
    DoModifyed;
  end;
end;

{ TUpdateableProject }

function TUpdateableProject.AddFileObj(obj: TUpdateFileObj; assoFileInfo: TUpdateableFileInfo): ERRCODE;
var
  tmp: TUpdateFileObj;
begin
  if (assoFileInfo <> nil) and (obj <> nil) then
  begin
    tmp := TUpdateFileObj(FindItemLowerLevel(obj.ObjID));
    if tmp <> nil then
      tmp.Assign(obj)
    else
    begin
      obj.ObjID.GenericID(OBJTYPE_ID);
      obj.FFileID := assoFileInfo.ObjID;
      obj := TUpdateFileObj(obj.Clone);
      AppendItem(obj);
    end;
    Result := ERRCODE_NOERROR;
  end
  else
    Result := ERRCODE_PARAMERROR;
end;

procedure TUpdateableProject.CheckUpdateableObjs;
var
  obj, tobj: TUpdateFileObj;
  S: CommonString;
begin
  if FDeployPath = '' then
    FDeployPath := ModuleFilePath
  else
    FDeployPath := ExpandPath(FDeployPath);
  obj := TUpdateFileObj(Item[0]);
  while obj <> nil do
  begin
    tobj := TUpdateFileObj(obj.Next);
    if obj.ClassID = TUpdateFileObj.ClassID then
    begin
      S := GetDeployName(obj);
      if not obj.DoCheckLocalVer(S) then
        ObjPool.ReturnObj(obj, Self);
    end;
    obj := tobj;
  end;
end;

class function TUpdateableProject.ClassID: Longword;
begin
  Result := CLASSID_CLIENTPROJECT;
end;

procedure TUpdateableProject.DoAssign(Source: TSerialObj);
var
  src: TUpdateableProject ABSOLUTE Source;
begin
  inherited;
  FDeployPath := src.FDeployPath;
end;

procedure TUpdateableProject.DoClone(Target: TSerialObj);
var
  tgt: TUpdateableProject ABSOLUTE Target;
begin
  inherited;
  tgt.FDeployPath := FDeployPath;
end;

procedure TUpdateableProject.DoReadFromPack(PropertyIdx, Len: Longword; Buf: TIOCPDataCollecter);
begin
  case PropertyIdx of
    3:
      ReadCommonStringFromPack(Buf, FDeployPath, Len);
  else
    inherited;
  end;
end;

procedure TUpdateableProject.DoWritePropertyToPack(dp: TIOCPDataCollecter);
begin
  inherited;
  WriteCommonStringToPack(dp, 3, FDeployPath);
end;

function TUpdateableProject.ExpandPath(S: CommonString): CommonString;
var
  i: Integer;

  procedure ReplaceEnvStr(pos: Integer; envstr: CommonString; repstr: CommonString);
  var
    tmp: CommonString;
  begin
    if pos <> 0 then
    begin
      tmp := Copy(Result, pos + Length(envstr), Length(Result));
      Delete(Result, pos, Length(Result));
      Result := Result + repstr + tmp;
    end;
  end;

  procedure ExpandEnv;
  var
    a: array [0 .. MAX_PATH] of WideChar;
  begin
    a[0] := #0;
    ExpandEnvironmentStringsW(PWideChar(Result), a, SizeOf(a));
    Result := a;
  end;

begin
  Result := Trim(S);
  while True do
  begin
    S := LowerCase(Result);
    i := pos(S_ENVIRONMENT_INSTALLPATH, S);
    if i <> 0 then
      ReplaceEnvStr(i, S_ENVIRONMENT_INSTALLPATH, FDeployPath)
    else
    begin
      i := pos(S_ENVIRONMENT_CURRENTPATH, S);
      if i <> 0 then
        ReplaceEnvStr(i, S_ENVIRONMENT_CURRENTPATH, ModuleFilePath)
      else
      begin
        i := pos(S_ENVIRONMENT_PROGRAMPATH, S);
        if i <> 0 then
          ReplaceEnvStr(i, S_ENVIRONMENT_PROGRAMPATH, '%ProgramW6432%')
        else
          Break;
      end;
    end;
  end;
  ExpandEnv;
  Result := RegularPath(Result);
end;

function TUpdateableProject.FindFileObjByFileID(const FileID: TID_OBJ): TUpdateFileObj;
begin
  Result := TUpdateFileObj(Item[0]);
  while Result <> nil do
  begin
    if Result.FileID = FileID then
      Break;
    Result := TUpdateFileObj(Result.Next);
  end;
end;

function TUpdateableProject.GetDeployName(obj: TUpdateFileObj): CommonString;
begin
  if obj <> nil then
  begin
    if obj.FDeployPath <> '' then
      Result := FDeployPath
    else if FDeployPath <> '' then
      Result := FDeployPath
    else
      Result := S_ENVIRONMENT_CURRENTPATH;
    Result := ExpandPath(Result) + obj.FDeployFileName;
  end
  else
    Result := '';
end;

procedure TUpdateableProject.Return;
begin
  inherited;
  FDeployPath := '';
end;

procedure TUpdateableProject.SetDeployPath(const Value: CommonString);
begin
  if FDeployPath <> Value then
  begin
    FDeployPath := Value;
    DoModifyed;
  end;
end;

procedure TUpdateableProject.UpdateFileObj(const FileID: TID_OBJ; FN: CommonString);
var
  fo: TUpdateFileObj;
  fnNew, fnOld: CommonString;
begin
  fo := FindFileObjByFileID(FileID);
  if fo <> nil then
  begin
    fnNew := GetDeployName(fo);
    CreatePath(fnNew);
    fnOld := fnNew + S_FILEEXT_OLD;
    DeleteFile(fnOld);
    RenameFile(fnNew, fnOld);
    if MoveFile(FN, fnNew) = ERRCODE_NOERROR then
      DbgPrintSysError(Format('Update file %s failed ', [fnNew]));
  end;
end;

{ TUpdateFileObj }

class function TUpdateFileObj.ClassID: Longword;
begin
  Result := CLASSID_UPDATEABLEFILEOBJ;
end;

procedure TUpdateFileObj.DoAssign(Source: TSerialObj);
var
  src: TUpdateFileObj ABSOLUTE Source;
begin
  inherited;
  FDeployPath := src.FDeployPath;
  FDeployFileName := src.FDeployFileName;
  // FFileNameOnSvr := src.FFileNameOnSvr;
  FFileID := src.FFileID;
  FFileHash := src.FFileHash;
  FModTime := src.FModTime;
  FVerOnSvr := src.FVerOnSvr;
  FFileSize := src.FFileSize;
  FUpdateMode := src.FUpdateMode;
end;

function TUpdateFileObj.DoCheckLocalVer(DepFullName: CommonString): Boolean;
var
  fv: TVER_INFO;
  ft: TFILETIME;
  l1, l2: PInt64;
begin
  if FUpdateMode = umOnlyNew then
  begin
    ft := GetFileModifyTime(DepFullName);
    l1 := @ft;
    l2 := @FModTime;
    Result := l1^ < l2^;
  end
  else
  begin
    fv := GetModuleVer(DepFullName);
    Result := (fv.Ver < FVerOnSvr.Ver);
    DbgPrint('%s Ver on server: %d.%d.%d.%d local: %d.%d.%d.%d', [DepFullName, FVerOnSvr.Lsh, FVerOnSvr.Lsl,
      FVerOnSvr.Maj, FVerOnSvr.Min, fv.Lsh, fv.Lsl, fv.Maj, fv.Min], L_DBGLEVEL_OUTPUT);
  end;
end;

procedure TUpdateFileObj.DoClone(Target: TSerialObj);
var
  tgt: TUpdateFileObj ABSOLUTE Target;
begin
  inherited;
  tgt.FDeployPath := FDeployPath;
  tgt.FDeployFileName := FDeployFileName;
  // tgt.FFileNameOnSvr := FFileNameOnSvr;
  tgt.FFileID := FFileID;
  tgt.FFileHash := FFileHash;
  tgt.FModTime := FModTime;
  tgt.FVerOnSvr := FVerOnSvr;
  tgt.FFileSize := FFileSize;
  tgt.FUpdateMode := FUpdateMode;
end;

procedure TUpdateFileObj.DoReadFromPack(PropertyIdx, Len: Longword; Buf: TIOCPDataCollecter);
var
  S: UnicodeString;
begin
  case PropertyIdx of
    3:
      ReadUnicodeStringFromPack(Buf, S, Len);
    4:
      Buf.ReadBuf(FFileID, Len);
    5:
      Buf.ReadBuf(FModTime, Len);
    6:
      Buf.ReadBuf(FVerOnSvr, Len);
    7:
      Buf.ReadBuf(FFileSize, Len);
    8:
      Buf.ReadBuf(FUpdateMode, Len);
    9:
      ReadCommonStringFromPack(Buf, FDeployPath, Len);
    10:
      ReadCommonStringFromPack(Buf, FDeployFileName, Len);
  else
    inherited;
  end;
end;

procedure TUpdateFileObj.DoWritePropertyToPack(dp: TIOCPDataCollecter);
begin
  inherited;
  // 注意：此处不能合并存储，否则传输的数据不正确
  // WriteUnicodeStringToPack2(dp, 3, FFileNameOnSvr);
  WritePropertyToPack(dp, 4, SizeOf(FFileID) + SizeOf(FFileHash), FFileID);
  WritePropertyToPack(dp, 5, SizeOf(FModTime), FModTime);
  WritePropertyToPack(dp, 6, SizeOf(FVerOnSvr), FVerOnSvr);
  WritePropertyToPack(dp, 7, SizeOf(FFileSize), FFileSize);
  WritePropertyToPack(dp, 8, SizeOf(FUpdateMode), FUpdateMode);
  WriteCommonStringToPack(dp, 9, FDeployPath);
  WriteCommonStringToPack(dp, 10, FDeployFileName);
end;

procedure TUpdateFileObj.Return;
begin
  inherited;
  FDeployPath := '';
  FDeployFileName := '';
  // FFileNameOnSvr := '';
  FFileID.Empty;
  FFileHash.Empty;
  FVerOnSvr.Ver := 0;
  FFileSize := 0;
end;

procedure TUpdateFileObj.SetDeployFileName(const Value: CommonString);
begin
  if FDeployFileName <> Value then
  begin
    FDeployFileName := Value;
    DoModifyed;
  end;
end;

procedure TUpdateFileObj.SetFileHash(const Value: THASH_VAL);
begin
  if FFileHash <> Value then
  begin
    FFileHash := Value;
    DoModifyed;
  end;
end;

procedure TUpdateFileObj.SetFileID(const Value: TID_OBJ);
begin
  if FFileID <> Value then
  begin
    FFileID := Value;
    DoModifyed;
  end;
end;

procedure TUpdateFileObj.SetFilePath(const Value: CommonString);
begin
  if FDeployPath <> Value then
  begin
    FDeployPath := Value;
    DoModifyed;
  end;
end;

procedure TUpdateFileObj.SetFileSize(const Value: int64);
begin
  if FFileSize <> Value then
  begin
    FFileSize := Value;
    DoModifyed;
  end;
end;

procedure TUpdateFileObj.SetModTime(const Value: FILETIME);
begin
  if (FModTime.dwLowDateTime <> Value.dwLowDateTime) or (FModTime.dwHighDateTime <> Value.dwHighDateTime) then
  begin
    FModTime := Value;
    DoModifyed;
  end;
end;

procedure TUpdateFileObj.SetUpdateMode(const Value: TUpdateMode);
begin
  if FUpdateMode <> Value then
  begin
    FUpdateMode := Value;
    DoModifyed;
  end;
end;

procedure TUpdateFileObj.SetVerOnSvr(const Value: TVER_INFO);
begin
  if FVerOnSvr.Ver <> Value.Ver then
  begin
    FVerOnSvr := Value;
    DoModifyed;
  end;
end;

initialization

ObjPool.RegisterObjClass(TUpdateableFileInfo);
ObjPool.RegisterObjClass(TUpdateableProject);
ObjPool.RegisterObjClass(TUpdateFileObj);

end.
